Delitos en época de COVID19

Row

Tabla de incidencia

Tipo de delito Incidencia en 2019 Incidencia en 2020 Porcentaje de cambio
Acoso sexual 4204 5597 33.14
Otros delitos que atentan contra la libertad y la seguridad sexual 6325 8032 26.99
Violación equiparada 3674 4225 15
Violencia familiar 210158 220039 4.7
Trata de personas 544 550 1.1
Feminicidio 943 939 -0.42
Homicidio doloso 29456 28808 -2.2
Abuso sexual 23625 22379 -5.27
Hostigamiento sexual 1860 1753 -5.75
Violación simple 13656 12320 -9.78
Lesiones dolosas 166440 144280 -13.31
Tráfico de menores 29 21 -27.59
Secuestro 1331 826 -37.94

Delitos sexuales y de género

Todos los delitos

Row

Cambio en la incidencia

Mapa nacional 1 y pruebas realizadas

Row

Mapa nacional de resultados positivos

Row

Pruebas realizadas por estado

Pruebas realizadas por estado

ENTIDAD_FEDERATIVA Numero de pruebas
AGUASCALIENTES 83806
BAJA CALIFORNIA 109825
BAJA CALIFORNIA SUR 92970
CAMPECHE 32329
CHIAPAS 36373
CHIHUAHUA 101440
CIUDAD DE MÉXICO 2282194
COAHUILA DE ZARAGOZA 164933
COLIMA 25528
DURANGO 80341
GUANAJUATO 295182
GUERRERO 86786
HIDALGO 72844
JALISCO 198164
MÉXICO 711102
MICHOACÁN DE OCAMPO 128509
MORELOS 150570
NAYARIT 25378
NUEVO LEÓN 281351
OAXACA 73380
PUEBLA 183100
QUERÉTARO 138412
QUINTANA ROO 54076
SAN LUIS POTOSÍ 169402
SINALOA 85312
SONORA 128552
TABASCO 210585
TAMAULIPAS 146113
TLAXCALA 63880
VERACRUZ DE IGNACIO DE LA LLAVE 126722
YUCATÁN 98351
ZACATECAS 63062

Mapa porcentaje de positividad

Row

Porcentaje total

Row

Porcentaje 2020

Porcentaje 2021

Ranking Nacional

Calificación por estado para manejo de la pandemia

ESTADO AVERAGE
CHIAPAS 100.00000
CAMPECHE 98.97495
NAYARIT 98.66991
COLIMA 97.95662
TLAXCALA 96.82548
QUINTANA ROO 96.33324
AGUASCALIENTES 95.41520
ZACATECAS 94.84600
MORELOS 94.68327
DURANGO 94.52600
GUERRERO 94.26253
HIDALGO 94.02030
YUCATÁN 93.92850
SINALOA 93.82744
OAXACA 93.69691
MICHOACÁN DE OCAMPO 93.24108
BAJA CALIFORNIA SUR 92.29654
BAJA CALIFORNIA 92.17957
CHIHUAHUA 91.34902
VERACRUZ DE IGNACIO DE LA LLAVE 91.23190
TAMAULIPAS 91.00486
SAN LUIS POTOSÍ 89.47525
TABASCO 88.69850
COAHUILA DE ZARAGOZA 88.65936
QUERÉTARO 88.22240
SONORA 87.45563
PUEBLA 87.04362
JALISCO 86.96110
NUEVO LEÓN 80.85763
GUANAJUATO 79.87569
MÉXICO 60.78893
CIUDAD DE MÉXICO 0.00000

Comparativa entre países (Contagios)

Column

Escenario mundial (población similar)

Column

Escenario LATAM

Vacunación en LATAM

Row

Escenario general

Estacionalidad (Mensual)

Estacionalidad (semanal por mes)

Vacunación en LATAM (Pronóstico TSLM)

Column

TSLM

Column

TSLM

Vacunación en LATAM (Pronóstico ETS)

Column

ETS

Column

ETS amortiguado

---
title: "COVID19 Dashboard"
output: 
  flexdashboard::flex_dashboard:
    orientation: rows
    vertical_layout: fill
    social: [ "twitter", "facebook", "menu"]
    source_code: embed
---

```{r setup, include=FALSE}
library(flexdashboard)
# library(knitr)

#integrar visualización
library(patchwork)

library(DT)
library(rpivotTable)
library(ggplot2)
library(plotly)
library(dplyr)
library(openintro)
library(highcharter)
library(ggvis)
library(tidyverse)
# library(tibbletime)
library(reactable)
library(htmltools)
library(fpp3)
library(feasts)
library(fable)
library(tsibble)
library(lubridate)
library(kableExtra)
library(formattable)
#importación y lectura
library(readxl)
library(tidyr)
library(vroom)
#Mapas
library(leaflet)
library(ggmap) # -> para obtener lon y lat de los municipios
library(raster)
library(spData)
library(tmap)
library(RJSONIO)
library(tmaptools)
library(Hmisc)
library(mxmaps) #se instala con un repo de gitgub con el 
                #siguiente comando
                #if (!require("devtools")) {
#     install.packages("devtools")
# }
# devtools::install_github("diegovalle/mxmaps")

library(sf)
library(scales) # needed for comma
library(rgeos)
library(maptools)
library(leaflet)
library(geojsonio)
library(jsonlite)

```


```{r}
# 
# data <- read_csv("VehicleFailure.csv")
  
delitos <- read_csv("../Delitos/delitos2015-2021.csv", 
                    locale(encoding = "latin1"),
                    col_names = TRUE, 
                    col_types = NULL
                 )
  #######Quedarse solo con las columnas y filas necesarias#######

delitos_a_comparar <- c("Feminicidio", "Abuso sexual", 
                        "Acoso sexual", "Hostigamiento sexual",
                        "Otros delitos que atentan contra la libertad y la seguridad sexual",
                        "Violación simple", "Violación equiparada", "Trata de personas",
                        "Tráfico de menores", "Secuestro", "Violencia familiar")

delitos_tidy <- delitos %>%
  filter( Tipo_de_delito %in% delitos_a_comparar | 
          Subtipo_de_delito == "Homicidio doloso" |
          Subtipo_de_delito == "Lesiones dolosas" ) %>% 
  pivot_longer(
  cols = Enero:Diciembre ,
  names_to = "Meses",
  values_to = "Cuenta"
) %>% 
  group_by(Ano, Meses, Tipo_de_delito, Subtipo_de_delito) %>% 
  summarise(Cuenta = sum(Cuenta), .groups = "drop")

delitos_tidy <- delitos_tidy %>% 
  mutate(
    Meses = str_trunc(Meses, width = 3, ellipsis = ""),
    Meses = case_when(
      Meses == "Ene" ~ "Jan",
      Meses == "Abr" ~ "Apr",
      Meses == "Ago" ~ "Aug",
      Meses == "Dic" ~ "Dec",
      TRUE           ~ Meses
    )
  ) %>% 
  unite(col = "Fecha", c(Ano,Meses), sep = " ") %>% 
  mutate(Fecha = yearmonth(Fecha))

delitos_tidy_tsbl <- delitos_tidy %>% 
  as_tsibble(
    index = Fecha,
    key   = c(Tipo_de_delito, Subtipo_de_delito)
  )
# 
# mycolors <- c("blue", "#FFC125", "darkgreen", "darkorange")
```

Delitos en época de COVID19
=====================================



























































Row
-------------------------------

### Tabla de incidencia

```{r}


#Tabla de incidencia (old)
# 
# Incidencia_2019 <-delitos_tidy_tsbl %>% 
#   tsibble::group_by_key() %>% 
#   tsibble::index_by(Año = year(Fecha)) %>% 
#   dplyr::summarise(Cuenta = sum(Cuenta)) %>% 
#   dplyr::filter(Año %in% 2019) %>%
#   dplyr::as_tibble(Incidencia_2019) %>%
#   dplyr::transmute( Delito = Tipo_de_delito, 
#                     Incidencia_2019 = Cuenta) 
# 
# Incidencia_2020 <- delitos_tidy_tsbl %>%
#   group_by_key() %>%
#   
#   index_by(Año = year(Fecha)) %>%
#   
#   dplyr::summarise(Cuenta = sum(Cuenta)) %>%
#   dplyr::filter(Año %in% 2020) %>%
#   dplyr::as_tibble(Incidencia_2020) %>%
#   dplyr::mutate(Delito = Tipo_de_delito,
#         Incidencia_2020 = Cuenta) %>%
#   dplyr::select(Delito, Incidencia_2020)
# 
# Incidencia <- Incidencia_2020 %>%
#   add_column(Incidencia_2019$Incidencia_2019) %>%
#   dplyr::mutate(
#     Porcentaje_de_cambio = round((
#       (Incidencia_2020 - Incidencia_2019$Incidencia_2019)/Incidencia_2020), digits = 5),
#     Incidencia_2019 = Incidencia_2019$Incidencia_2019) %>%
#   
#   dplyr::select(Delito, Incidencia_2019, Incidencia_2020, Porcentaje_de_cambio)%>%
#   arrange(desc(Porcentaje_de_cambio)) 
#  
# Tabla <- Incidencia %>%
#   mutate(Porcentaje_de_cambio =  percent(Porcentaje_de_cambio, 2)) %>%
#   kbl(fortmat = "htlm", col.names = c("Delitos",
#                                       "Incidencia en 2019",
#                                       "Incidencia en 2020",
#                                       "Porcentaje de cambio")) %>%
#   
#   kable_styling(bootstrap_options = "striped",
#                 full_width = F,
#                 position = "left",
#                 font_size = 14) %>%
#   
#   column_spec(4,color = ifelse( Incidencia$Porcentaje_de_cambio > 0, "red", "green"))
# Tabla


#Tabla de incidencia (new -> 13/marzo/2021)

incidencias <- delitos_tidy_tsbl %>% 
  group_by_key() %>% 
  index_by(Año = year(Fecha)) %>% 
  summarise(Cuenta = sum(Cuenta)) %>% 
  as_tibble(incidencias) %>% 
  mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>% 
  filter(Año != 2021)

Todos_delitos_gg <- incidencias %>% 
  ggplot(aes(x = Año, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

# perc_cambio_incidencias <- incidencias %>%
#   ggplot(aes(x = Año, y = cambio, color = Subtipo_de_delito)) +
#   geom_line() +
#   geom_line(size = 1)+
#   facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
#   theme(legend.position = "none")
# plotly::ggplotly(perc_cambio_incidencias)

incidencias <- incidencias %>% 
  pivot_wider(names_from = Año, values_from = Cuenta:cambio)

Tabla <- incidencias %>%
  dplyr::select( Subtipo_de_delito, Cuenta_2019, Cuenta_2020, cambio_2020) %>%
  arrange(-cambio_2020) %>%
  transmute('Tipo de delito' = Subtipo_de_delito,
            'Incidencia en 2019' = Cuenta_2019,
            'Incidencia en 2020' = Cuenta_2020,
            'Porcentaje de cambio' =  round(cambio_2020, digits = 2))

customGreen0 = "#DeF7E9"

customGreen = "#71CA97"

customRed = "#ff7f7f"

cambio_format <- 
  formatter("span", 
            style = x ~ formattable::style(
              font.weight = "bold",
              color = ifelse(x < 0, customGreen, ifelse(x > 0, customRed, "black"))),
            x ~ icontext(ifelse(x>0, "arrow-up", "arrow-down"), x)
  ) 

formattable(Tabla, 
            align = c("l", rep("r", NCOL(Tabla) - 1)),
            list('Tipo de delito' = formatter("span", style = ~ formattable::style(color = "grey", font.weight = "bold")),
                 'Porcentaje de cambio' = cambio_format
            ))
 


```


### Delitos sexuales y de género

```{r}

sexuales_y_genero = c("Abuso sexual", 
                      "Acoso sexual",
                      "Feminicidio", 
                      "Violación simple", 
                      "Violación equiparada", 
                      "Hostigamiento sexual", 
                      "Otros delitos que atentan contra la libertad y la seguridad sexual")

# Grafica old
# p2 <-  delitos_tidy_tsbl %>%
#   filter (Tipo_de_delito %in% sexuales_y_genero) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p2

delitos_sexuales_y_genero_gg <- delitos_tidy_tsbl %>%
  filter (Tipo_de_delito %in% sexuales_y_genero) %>%
  ggplot(aes(x = Fecha, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

delitos_sexuales_y_genero_gg
```

```{r}
#CargaDeDatos para generar gráficas de los delitos totales y en tasa de cambio

incidencias <- delitos_tidy_tsbl %>% 
  group_by_key() %>% 
  index_by(Anual = year(Fecha)) %>% 
  summarise(Cuenta = sum(Cuenta)) %>% 
  as_tibble(incidencias) %>% 
  mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>% 
  filter(Anual != 2021)

```


### Todos los delitos

```{r}
#gráfica old, delitos contra la libertad
# p3 <- delitos_tidy_tsbl %>%
#   filter (Tipo_de_delito %in% c("Trata de personas", "Tráfico de menores", "Secuestro") ) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p3

Todos_delitos_gg <- incidencias %>% 
  ggplot(aes(x = Anual, y = Cuenta, color = Tipo_de_delito)) +
  geom_line(size = 1)+
  facet_wrap(~ Tipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")

Todos_delitos_gg
```

Row
------------------------------------
### Cambio en la incidencia  

```{r}
# gráfica old, delitos dolosos 
# p4 <- delitos_tidy_tsbl %>%
#   filter(Subtipo_de_delito %in% c("Lesiones dolosas", "Homicidio doloso")) %>%
#   ggplot() + 
#   geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
# 
# p4

perc_cambio_incidencias <- incidencias %>%
  ggplot(aes(x = Anual, y = cambio, color = Subtipo_de_delito)) +
  geom_line() +
  geom_line(size = 1)+
  facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
  theme(legend.position = "none")
plotly::ggplotly(perc_cambio_incidencias)
```













Mapa nacional 1 y pruebas realizadas
========================================

Row
------------------------------------

### Mapa nacional de resultados positivos 

```{r}
# car <- data %>%
#          group_by(State) %>%
#          summarize(total = n())
# car$State <- abbr2state(car$State)
# 
# highchart() %>%
#          hc_title(text = "Car Failures in US") %>%
#          hc_subtitle(text = "Source: Vehiclefailure.csv") %>%
#          hc_add_series_map(usgeojson, car,
#                            name = "State",
#                            value = "total",
#                            joinBy = c("woename", "State")) %>%

#          hc_mapNavigation(enabled = T)
# lubridate::today()-1
# fecha <- "210415"



options(timeout = 700)
temp <- tempfile()
download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)


Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name)))
unlink(temp)

```


```{r}
Entidades <- read_xlsx("../Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")

# Clasificación de datos  -------------------------------------------------

#datos necesarios para la prueba
datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`,
                                 `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`,
                                 `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>%
  left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))

#datos confirmados sin realización de pruebas
confirmados <- datosimportates %>% 
  filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% 
  dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>% 
  mutate(
    year = lubridate::year(FECHA_INGRESO),
    month = lubridate::month(FECHA_INGRESO),
    day = lubridate::day(FECHA_INGRESO)
  ) %>% 
  drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) 

# Agrupación de datos  ----------------------------------------------------
#Numero de positivos por estado
positivosestado <- confirmados %>%
  group_by(`ENTIDAD_RES`) %>%
  summarise(
    count=n(),
  )

#Selección de nombre estados, por orden de codigo
nombreEstado <- Entidades %>%
  dplyr::select(`ENTIDAD_FEDERATIVA`) %>%
  slice( 1:32)

mapaPositivos <- positivosestado %>%
  add_column(nombreEstado)

# Mapa  -------------------------------------------------------------------

# data(mapaPositivos)
# mapaPositivos$rand <- mapaPositivos$count
# mapaPositivos$region <- mapaPositivos$ENTIDAD_RES
# mxstate_choropleth(mapaPositivos,
#                    title = "Casos confirmados de COVID por estado.",
#                    legend = "Número de casos.",
# )


# Convert the topoJSON to spatial object
tmpdir <- tempdir()
# have to use RJSONIO or else the topojson isn't valid
write(RJSONIO::toJSON(mxstate.topoJSON), file.path(tmpdir, "sta.topojson"))
mxstate <- topojson_read(file.path(tmpdir, "sta.topojson")) 


#ordenamos los datos del topoJSON en orden numérico
mxstate <- mxstate[order(mxstate$id),]


mxstate <- as_Spatial(mxstate)

mxstate$rand <- mapaPositivos$count

bins <- c(5000,20000 , 30000, 35000, 50000, 60000, 115000,300000, Inf)
pal <- colorBin("YlOrRd", domain = mxstate$rand, bins=bins)


etiqueta <- paste(
  "Estado: ", mapaPositivos$ENTIDAD_FEDERATIVA, "
", "Número de casos: ", mapaPositivos$count ) %>% lapply(htmltools::HTML) leaflet(mxstate) %>% addPolygons( fillColor = ~pal(mxstate$rand), fillOpacity = 1, stroke = TRUE, color = "White", weight = 1.5, dashArray = "3", highlight = highlightOptions( weight = 5, color = "#666", dashArray = "", fillOpacity = 0.7, bringToFront = TRUE), label = etiqueta, )%>% addLegend(pal = pal, values = ~mapaPositivos$rand, opacity = 0.7, title = "Casos
positivos
contagios", position = "bottomright")%>% addTiles() %>% addMarkers(50, 50) %>% addControl("Positivos totales COVID19 México", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` Row ------------------------------------ ### Pruebas realizadas por estado ```{r} # # Importación de datos ---------------------------------------------------- # # # # Datosmex2502 <- read_csv("210225COVID19MEXICO.csv") # # Descarga de datos desde la página web # fecha <- "210412" # options(timeout = 600) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, paste0(fecha,"COVID19MEXICO.csv"))) # unlink(temp) # # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # # Clásificación ---------------------------------------------------------- # # #datos necesarios para la prueba # datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`, # `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, # `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>% # left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) #datos de las pruebas realizadas ese día en todo el país pruebasfiltro <- datosimportates %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>% mutate( year = lubridate::year(FECHA_INGRESO), month = lubridate::month(FECHA_INGRESO), day = lubridate::day(FECHA_INGRESO) ) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) # Agrupación de datos ---------------------------------------------------- #Numero de pruebas por estado totales hasta la fecha de datos pruebasXEstado <- pruebasfiltro %>% group_by(`ENTIDAD_FEDERATIVA`) %>% mutate(`Numero de pruebas`=n()) %>% distinct(`ENTIDAD_FEDERATIVA`, .keep_all = TRUE) %>% arrange(`ENTIDAD_FEDERATIVA`) %>% drop_na(`ENTIDAD_FEDERATIVA`) pruebasXEstado <- pruebasXEstado %>% dplyr::select( `ENTIDAD_FEDERATIVA`, `Numero de pruebas` ) pruebasfiltro$FECHA_INGRESO <- format(pruebasfiltro$FECHA_INGRESO, "%Y-%m") #Numero de pruebas por estado según el día pruebasxEstadoxDia <- pruebasfiltro %>% group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(count=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% drop_na(`ENTIDAD_FEDERATIVA`) # Gráfica ---------------------------------------------------------------- ggplot(data = pruebasfiltro) + geom_bar(mapping = aes(y = FECHA_INGRESO, fill = ABREVIATURA), position = "dodge") ``` ### Pruebas realizadas por estado ```{r} # Tabla ------------------------------------------------------------------ #Tabla que muestra el número de pruebas que se hacen por día en los estados formattable(pruebasXEstado, #llamo datos align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna list(`ENTIDAD_FEDERATIVA` = formatter( #datos específicos "span", style = ~ style(color = "grey",font.weight = "bold")), `Numero de pruebas` = color_bar("Red") # me crea una barra roja con proporción a los datos ) ) ``` Mapa porcentaje de positividad ======================================== Row ------------------------------------ ### Porcentaje total ```{r} # Importación de datos ---------------------------------------------------- #Datosmex2502 <- read_csv("210225COVID19MEXICO.csv") # Descarga de datos desde la página web # fecha <- "210414" # options(timeout = 700) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name))) # unlink(temp) # # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # # # Clasificación de datos ------------------------------------------------- # # #datos necesarios para la prueba # datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`, # `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, # `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>% # left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) # # # # #datos confirmados sin realización de pruebas # confirmados <- datosimportates %>% # filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% # dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>% # mutate( # year = lubridate::year(FECHA_INGRESO), # month = lubridate::month(FECHA_INGRESO), # day = lubridate::day(FECHA_INGRESO) # ) %>% # drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #datos de las pruebas realizadas ese día en todo el país pruebasfiltro <- datosimportates %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>% mutate( year = lubridate::year(FECHA_INGRESO), month = lubridate::month(FECHA_INGRESO), day = lubridate::day(FECHA_INGRESO) ) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #Separación de datos por fechas para mapas pruebas2020 <- dplyr::filter(pruebasfiltro, year==2020) pruebEstado2020 <- pruebas2020 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) pruebas2021 <- dplyr::filter(pruebasfiltro, year==2021) pruebEstado2021 <- pruebas2021 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) #confirmados por año para mapas confirm2020 <- confirmados %>% dplyr::filter( year==2020) %>% drop_na(`ENTIDAD_FEDERATIVA`) confirmEstado2020 <- confirm2020 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) confirm2021 <- confirmados %>% dplyr::filter( year==2021) %>% drop_na(`ENTIDAD_FEDERATIVA`) confirmEstado2021 <- confirm2021 %>% group_by(`ENTIDAD_RES`) %>% summarise( count=n() ) #Numero de pruebas por estado totales hasta la fecha de datos pruebasXEstado <- pruebasfiltro %>% group_by(`ENTIDAD_RES`) %>% mutate(PRUEBAS=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% drop_na() # #Numero de pruebas por estado según el día # pruebasxEstadoxDia <- pruebasfiltro %>% # group_by(`ENTIDAD_RES`,`FECHA_INGRESO`) %>% # mutate(count=n()) %>% # distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% # arrange(`ENTIDAD_RES`) %>% # drop_na() # # # prubeasXEstadotsbl <- pruebasxEstadoxDia %>% # as_tsibble( key = `ENTIDAD_RES`, # index = `FECHA_INGRESO` # ) # group_split(pruebasxEstadoxDia) # group_keys(pruebasxEstadoxDia) #Positivos por estado totales hasta la fecha de datos positivoxEstado <- confirmados %>% group_by(`ENTIDAD_RES`) %>% mutate(CONFIRMADOS=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(ENTIDAD_RES, ENTIDAD_FEDERATIVA, CONFIRMADOS ) # #Positivos por estado según el día # positivoxEstadoxDia <- confirmados %>% # group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(count=n()) %>% # distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% # arrange(`ENTIDAD_RES`) %>% # drop_na() # # positivoXDiatsbl <- positivoxEstadoxDia %>% # as_tsibble( key = ENTIDAD_RES, # index = FECHA_INGRESO # # ) #Selección de nombre estados, por orden de codigo nombreEstado <- Entidades %>% dplyr::select(`ENTIDAD_FEDERATIVA`) %>% slice( 1:32) # Agrupación de datos totales ----------------------------------------------------- # #suma total de las pruebas realizadas totalpruebas <- pruebasXEstado$PRUEBAS %>% sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas <- positivoxEstado$CONFIRMADOS %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividadPais <- (totalpositivas/totalpruebas)*100 #positividadPais positividad <- ((positivoxEstado$CONFIRMADOS/pruebasXEstado$PRUEBAS)*100) #positividad #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado <- (positivoxEstado$CONFIRMADOS/totalpositivas)*100 porcenestado <- as.numeric(porcenestado) #porcenestado #Porcentaje total de pruebas positvas porcen <- sum(positividad, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje <- sum(porcenestado, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva <- positivoxEstado %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado)%>% #agregamos porcentajes del total de pruebas add_column(positividad) %>% add_column(pruebasXEstado$PRUEBAS) # #Agregamos el nombre de los estados por orden de codigo # add_column(nombreEstado) # Agrupación de datos 2020 ------------------------------------------------ # #suma total de las pruebas realizadas # totalpruebas2020 <- pruebEstado2020$count %>% # sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas2020 <- confirmEstado2020$count %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividad2020 <- (confirmEstado2020$count/pruebEstado2020$count)*100 #positividad2020 #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado2020 <- (confirmEstado2020$count/totalpositivas2020)*100 porcenestado2020 <- as.numeric(porcenestado) #porcenestado2020 #Porcentaje total de pruebas positvas porcen2020 <- sum(positividad2020, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje2020 <- sum(porcenestado2020, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva2020 <- confirmEstado2020 %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado2020)%>% #agregamos porcentajes del total de pruebas add_column(positividad2020) %>% #Agregamos el nombre de los estados por orden de codigo add_column(nombreEstado) # Agrupación de datos 2021 ------------------------------------------------ # #suma total de las pruebas realizadas # totalpruebas2021 <- pruebEstado2021$count %>% # sum(na.rm = TRUE) #suma total de las pruebas que salieron positivas totalpositivas2021 <- confirmEstado2021$count %>% sum(na.rm = TRUE) #Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados positividad2021 <- (confirmEstado2021$count/pruebEstado2021$count)*100 #positividad2021 #porcentaje total de las pruebas positivas de acuerdo a que estado. porcenestado2021 <- (confirmEstado2021$count/totalpositivas2021)*100 porcenestado2021 <- as.numeric(porcenestado2021) #porcenestado2021 #Porcentaje total de pruebas positvas porcen2021 <- sum(positividad2021, na.rm = TRUE) #verificación de suma de porcentaje de pruebas positivas (porcenestado) sumporcentaje2021 <- sum(porcenestado2021, na.rm = TRUE) # creamos tibble con datos de codigo de entidad y casos positivos nueva2021 <- confirmEstado2021 %>% #agregamos porcentajes de acuerdo al total de pruebas positivas add_column(porcenestado2021)%>% #agregamos porcentajes del total de pruebas add_column(positividad2021) %>% #Agregamos el nombre de los estados por orden de codigo add_column(nombreEstado) # Mapa de positividad total -------------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado) #data(nueva) nueva$value <- nueva$positividad nueva$region <- nueva$ENTIDAD_RES # mxstate_choropleth(nueva, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva$value, bins=bins) mxstate_leaflet(nueva, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de las pruebas totales", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` Row ------------------------------------ ### Porcentaje 2020 ```{r} # Mapa 2020 --------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado del año 2020) data(nueva2020) nueva2020$value <- nueva2020$positividad2020 nueva2020$region <- nueva2020$ENTIDAD_RES # mxstate_choropleth(nueva, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins=c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva2020$value, bins=bins) mxstate_leaflet(nueva2020, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva2020$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de las pruebas en 2020", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` ### Porcentaje 2021 ```{r} # Mapa 2021 --------------------------------------------------------------- # de acuerdo al número de pruebas realizadas se calcula el porcentaje de las #pruebas que fueron seleccionadas como positivas. (por estado del año 2021) data(nueva2021) nueva2021$value <- nueva2021$positividad2021 nueva2021$region <- nueva2021$ENTIDAD_RES # mxstate_choropleth(nueva2021, # num_colors = 1, # title = "Porcentaje de casos positivos", # legend = "%", # ) #Mapa interactivo bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72) pal <- colorBin("viridis", domain = nueva2021$value, bins=bins) mxstate_leaflet(nueva2021, pal, ~ pal(value), ~ sprintf("Estado: %s
Porcentaje de positividad : %s", ENTIDAD_FEDERATIVA , comma(value) )) %>% addLegend(position = "bottomright", pal = pal, values = nueva2021$value, title = "Percentaje
Positividad", labFormat = labelFormat(suffix = "%", )) %>% addTiles() %>% addMarkers(50, 50) %>% addControl("Mapa positividad de pruebas en 2021", position = "bottomleft") %>% addProviderTiles("CartoDB.Positron") ``` ```{r} # Carga de datos ---------------------------------------------------------- #Se importan los datos como un tibble Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv") # Wrangle data ------------------------------------------------------------ #Se quiere trabajar con series de tiempo, entonces convertimos # a tsibble un objeto que tiene orientación a este tiempo de #procesamiento Vacunastotales_tsibble <- Vacunastotales %>% dplyr::mutate(Daily = as.Date(date)) %>% dplyr::select(-date) %>% tsibble::as_tsibble(key = location, index = Daily) #se hace una variable con los nombres de los paises de #LATAM para asi poder llamar la variable a buscar en #la base de datos si se requiere, esto esta pensado #en que la instrucción podría hacerse varias veces #entonces en teoría debería simplificar el código latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Se encontro que era particularmente complicado mostrar #todos los datos en una sola gráfica, por lo tanto, #graficar por secciones y pegar con patchwork es una #opción viable, por lo que la variable length(latam) = 14 #entonces dividimos en 2 grupos para tener símetria. latam1 <- latam[1:7] latam2 <- latam[8:14] #latam == latam1 + latam2 #hacemos otro dafa frame que solo sea para los de #LATAM y asi trabajamos con un tsibble más pequeña Vacunas_latam_tsibble <- Vacunastotales_tsibble %>% dplyr::select( Daily, location, total_vaccinations, total_vaccinations_per_hundred, daily_vaccinations_per_million) %>% filter(location %in% latam) ``` Ranking Nacional ========================================= ### Calificación por estado para manejo de la pandemia ```{r echo = FALSE, results= 'hide'} # # Importación de datos ---------------------------------------------------- # # # Descarga de datos desde la página web # # fecha <- "210415" # options(timeout = 700) # temp <- tempfile() # download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp) # # # Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name))) # unlink(temp) # # Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES") # Selección de datos ------------------------------------------------------ #datos necesarios para la prueba FiltImpoData <- dplyr::select(Datosmex2502, `FECHA_INGRESO`, `ENTIDAD_RES`, `TOMA_MUESTRA_LAB`, `RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`, `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`, `FECHA_DEF`, )%>% left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD")) #Población en cada estado del país, con datos a 2020 poblacionEstado <- dplyr::select(df_mxstate_2020, `region`, `state_name`, `pop`, ) # Filtro de datos en tibbles --------------------------------------------------------- #datos confirmados confirm <- FiltImpoData %>% filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) %>% #borramos los datos NA que generan más filas(son pocos) arrange(`FECHA_INGRESO`) #Casos terminados en muerte muertesConfirm <- FiltImpoData %>% filter(!is.na(`FECHA_DEF`)) %>% drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #quitamos datos NA (no interfiere) #datos de las pruebas realizadas ese día en todo el país filtroPrueba <- FiltImpoData %>% dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% #seleccuón de datos con pruebas drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #borrar datos NA (no afecta) # Medias moviles de los estados casos positivos ----------------------------------------------------- positivosXEstaXDia <- confirm %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(POSITIVOS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `POSITIVOS`, ) #promedio de los últimos catorce días positivosXEstaXDia %>% group_by(ENTIDAD_FEDERATIVA) %>% slice_tail(n = 14) # %>% # summarise(Promedio = mean(POSITIVOS)) #media movil de 14 días positivos_tsbl <- positivosXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVOS, mean, .before = 14, .complete = TRUE) ) # #gráfica de los positivos con la medi movil # positivos_tsbl %>% # feasts::autoplot(POSITIVOS) + # geom_line(aes(y = `14-MA`), color = "black") + # facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") + # theme(legend.position = "none") # Medias moviles de los estados casos negativos --------------------------- muertesXEstaXDia <- muertesConfirm %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(MUERTES=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `MUERTES` ) #promedio de los últimos catorce días muertesXEstaXDia %>% group_by(ENTIDAD_FEDERATIVA) %>% slice_tail(n = 14) # %>% # summarise(Promedio = mean(MUERTES)) #media movil de 14 días muertes_tsbl <- muertesXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(MUERTES, mean, .before = 14, .complete = TRUE) ) # #gráfica de los positivos con la medi movil # muertes_tsbl %>% # feasts::autoplot(MUERTES) + # geom_line(aes(y = `14-MA`), color = "black") + # facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") + # theme(legend.position = "none") # medias movil positivos por millon de habitantes ------------------------- positivosXEstaXDiaXmillon <- positivosXEstaXDia %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) positivosXEstaXDiaXmillon$POSITIVOS <- (positivosXEstaXDiaXmillon$POSITIVOS*1000000)/positivosXEstaXDiaXmillon$pop #media movil de 14 días positivosmillon_tsbl <- positivosXEstaXDiaXmillon %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVOS, mean, .before = 14, .complete = TRUE) ) # media movil muertes por millon de habitantes ---------------------------- muertesXEstaXDiaXmillon <- muertesXEstaXDia %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) muertesXEstaXDiaXmillon$MUERTES <- (muertesXEstaXDiaXmillon$MUERTES*1000000)/muertesXEstaXDiaXmillon$pop #media movil de 14 días muertesmillon_tsbl <- muertesXEstaXDiaXmillon %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(MUERTES, mean, .before = 14, .complete = TRUE) ) # media movil de la positividad ------------------------------------------- PruePosiXEstaXDia <- filtroPrueba %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(PRUEBAS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `PRUEBAS`) %>% left_join(positivosXEstaXDia, positivosXEstaXDia, by= c("ENTIDAD_RES", "FECHA_INGRESO", "ENTIDAD_FEDERATIVA")) PruePosiXEstaXDia$POSITIVIDAD <- (PruePosiXEstaXDia$POSITIVOS/PruePosiXEstaXDia$PRUEBAS)*100 #media movil de 14 días positivdad_tsbl <- PruePosiXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(POSITIVIDAD, mean, .before = 14, .complete = TRUE) ) # Media movil de pruebas por cada 1000 habitantes -------------------------- pruebasXEstaXDia<- filtroPrueba %>% dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% mutate(PRUEBAS=n()) %>% distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% arrange(`FECHA_INGRESO`) %>% dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `FECHA_DEF`, `PRUEBAS`) %>% left_join(poblacionEstado, by=c("ENTIDAD_RES"="region")) pruebasXEstaXDia$XMILHAB <- ((1000*pruebasXEstaXDia$PRUEBAS)/pruebasXEstaXDia$pop) #media movil de 14 días pruebas_tsbl <- pruebasXEstaXDia %>% ungroup() %>% as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>% mutate( `14-MA` = slider::slide_dbl(XMILHAB, mean, .before = 14, .complete = TRUE) ) # Indicadores por día en cada estado ------------------------------------- # #Por día hacemos un conteo de los casos que se confirmaron en cada estado # positivosXEstaXDia <- confirm %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(POSITIVOS=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `POSITIVOS`, # )# %>% # # add_column(SUMS=NA) # # #Para generar las tablas de cada uno de los estados con su conteo # for(i in unique(positivosXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste0("positivoE.", i ) # assign(nam, positivosXEstaXDia[positivosXEstaXDia$`ENTIDAD_RES`==i,]) # # } # # muertesXEstaXDia <- muertesConfirm %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(MUERTES=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `MUERTES` # ) # for(i in unique(muertesXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste("muertesE", i, sep = ".") # assign(nam, muertesXEstaXDia[muertesXEstaXDia$ENTIDAD_RES==i,]) # } # pruebasXEstaXDia <- filtroPrueba %>% # dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>% # mutate(PRUEBAS=n()) %>% # distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>% # arrange(`FECHA_INGRESO`) %>% # select(`FECHA_INGRESO`, # `ENTIDAD_RES`, # `ENTIDAD_FEDERATIVA`, # `FECHA_DEF`, # `PRUEBAS`) # for(i in unique(pruebasXEstaXDia$`ENTIDAD_RES`)) { # nam <- paste("pruebasE", i, sep = ".") # assign(nam, pruebasXEstaXDia[pruebasXEstaXDia$ENTIDAD_RES==i,]) # # add_column(rollsumr("pruebasE".i$PRUEBAS, k = 14, fill = NA)) # # pruebasE.i$promedio <- rollmean(`PRUEBAS`, k = 14, fill = NA, aling="rigth") # } # for (i in tibble("pruebasE", i,sep="·")){ # tibble("pruebasE", i,sep="·")$sums <-rollsumr(PRUEBAS, k = 14, fill = NA) %>% # tibble("pruebasE", i,sep="·")$promedio <- rollmean(PRUEBAS, k = 14, fill = NA, aling="rigth") # } # Promedio al día indicadores por estados ------------------------------------------------------------- positivosXEstados <- confirm %>% group_by(`ENTIDAD_RES`) %>% mutate(Positivos=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select( `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Positivos`) # #gestapo positivos al día en cada estado # positivosXEstaXDia <- positivosXEstaXDia %>% # ungroup() %>% # group_by(`ENTIDAD_RES`) %>% # mutate( # PROM=mean(POSITIVOS) # # ) muertesXEstado <- muertesConfirm %>% group_by(`ENTIDAD_RES`) %>% mutate(Muertes=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(`ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Muertes`) # #promedios de muertes al día en cada estado # muertesXEstaXDia <- muertesXEstaXDia %>% # ungroup() %>% # group_by(`ENTIDAD_RES`) %>% # mutate( # PROM=mean(MUERTES) # # ) pruebasXEstado <- filtroPrueba %>% group_by(`ENTIDAD_RES`) %>% mutate(Pruebas=n()) %>% distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>% arrange(`ENTIDAD_RES`) %>% dplyr::select(`ENTIDAD_RES`, # selección de datos necesarios `ENTIDAD_FEDERATIVA`, `ABREVIATURA`, `Pruebas`) # Por millon de habitantes ------------------------------------------------ posiXEstaXMillon <- ((1000000*positivosXEstados$Positivos)/poblacionEstado$pop) muerteXEstaXMillon <- ((1000000*muertesXEstado$Muertes)/poblacionEstado$pop) # Positividad ------------------------------------------------------------ PositividadIndica <- (positivosXEstados$Positivos/pruebasXEstado$Pruebas)*100 # Pruebas por mil habitantes --------------------------------------------- pruebasXEstaXMilhab <- ((1000*pruebasXEstado$Pruebas)/poblacionEstado$pop) # Tabla con datos finales xEstado ------------------------------------------------- indicadoresFinal <- positivosXEstados %>% tibble::add_column(muertesXEstado$Muertes) %>% tibble::add_column(pruebasXEstado$Pruebas) %>% tibble::add_column(posiXEstaXMillon) %>% tibble::add_column(muerteXEstaXMillon) %>% tibble::add_column(PositividadIndica) %>% tibble::add_column(pruebasXEstaXMilhab) indicadoresFinal <- indicadoresFinal %>% ungroup() %>% group_by(`ENTIDAD_FEDERATIVA`) %>% mutate( SUM= sum(`Positivos`, `muertesXEstado$Muertes`, posiXEstaXMillon, muerteXEstaXMillon, PositividadIndica, pruebasXEstaXMilhab, na.rm = TRUE), PROM = (SUM/6) ) PromIndica <- indicadoresFinal %>% dplyr::select(`ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `PROM`) # summary(PromIndica) # Normalización ---------------------------------------------------------- # library(caret) # # # preproc2 <- preProcess(PromIndica[,c(1:3)], method=c("range")) # # norm2 <- predict(preproc2, PromIndica[,c(1:3)]) # # summary(norm2) normalize <- function(x) { return (((x - min(x))*(100) / (max(x) - min(x)))) } calificacion <- function(x) { return (100-(((x - min(x))*(100) )/ (max(x) - min(x)))) } PromIndica$NORM <- normalize(PromIndica$PROM) PromIndica$AVERAGE <- calificacion(PromIndica$PROM) # Tabla Calificación ----------------------------------------------------- calif <- PromIndica %>% dplyr::select(`ENTIDAD_FEDERATIVA`, `AVERAGE` ) %>% arrange(desc(AVERAGE)) colnames(calif)[colnames(calif)=="ENTIDAD_FEDERATIVA"] <- "ESTADO" ``` ```{r} #Tabla que muestra el número de pruebas que se hacen por día en los estados formattable(calif, #llamo datos align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna list(`ESTADO` = formatter( #datos específicos "span", style = ~ formattable::style(color = "grey",font.weight = "bold")), `AVERAGE` = color_tile("transparent", "orange")# me crea una barra roja con proporción a los datos ) ) ``` Comparativa entre países (Contagios) ========================================= ```{r} #Carga de datos que se necesitan para generar los datos de este sección nuevos_casos_mundiales <- read_csv("https://raw.github.com/owid/covid-19-data/master/public/data/jhu/full_data.csv") casos_por_millon <- read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/jhu/new_cases_per_million.csv") # creación de variables que se necesitan para esta sección #vector para la selección de paises con población similar poblacion_similiar <- c("Mexico", "Japan", "Russia", "Bangladesh", "Philippines") #Paises de LATAM latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Para la grafica GraphLatam Comparativa_casos_latam <- casos_por_millon %>% dplyr::select(date, matches(latam)) %>% pivot_longer( cols = 'Mexico':'Dominican Republic', names_to = "Paises", values_to = "Casos_por_millon" ) %>% filter( Paises != "Ecuador") Comparativa_casos_latam_tsbl<- Comparativa_casos_latam %>% as_tsibble( index = date, key = Paises ) ``` Column ------------------------------------ ### Escenario mundial (población similar) ```{r} Comparativa_nuevos_casos <- nuevos_casos_mundiales %>% ggplot(aes(x = date, y = new_cases, group = location)) + geom_line(color = "grey") + geom_line(data = nuevos_casos_mundiales %>% filter(location %in% poblacion_similiar), aes(color = location), size = 1) + scale_y_log10() + labs(title = 'Países población similar', x = 'Nuevos casos' , y = 'Fecha') Comparativa_nuevos_casos ``` Column ------------------------------------ ### Escenario LATAM ```{r} GraphLatam <- Comparativa_casos_latam_tsbl %>% filter(Paises != "Ecuador") %>% #Se elimina ecuador de la lista de paises por datos críticos negativos as_tsibble( index = date )%>% ggplot() + geom_line(mapping = aes(x = date, y = Casos_por_millon, color = Paises)) + facet_wrap(~ Paises, scales = "free_y") + theme(legend.position = "none") + labs(title = 'Comparación LATAM', x = 'Fecha', y = 'Casos por millón') GraphLatam ``` Vacunación en LATAM ========================================= ```{r} #Datos de manejo y de carga para generar las visualizaciones en esta seccion #carga de datos #Se importan los datos como un tibble Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv") #wrangle #Se quiere trabajar con series de tiempo, entonces convertimos # a tsibble un objeto que tiene orientación a este tiempo de #procesamiento Vacunastotales_tsibble <- Vacunastotales %>% dplyr::mutate(Daily = as.Date(date)) %>% dplyr::select(-date) %>% tsibble::as_tsibble(key = location, index = Daily) #se hace una variable con los nombres de los paises de #LATAM para asi poder llamar la variable a buscar en #la base de datos si se requiere, esto esta pensado #en que la instrucción podría hacerse varias veces #entonces en teoría debería simplificar el código latam <- c("Mexico", "Argentina", "Colombia", "Chile", "Brazil", "Bolivia", "Costa Rica", "Ecuador", "Guatemala", "Panama", "Paraguay", "Peru", "Puerto Rico", "Dominican Republic") #Se encontro que era particularmente complicado mostrar #todos los datos en una sola gráfica, por lo tanto, #graficar por secciones y pegar con patchwork es una #opción viable, por lo que la variable length(latam) = 14 #entonces dividimos en 2 grupos para tener símetria. latam1 <- latam[1:7] latam2 <- latam[8:14] #latam == latam1 + latam2 #hacemos otro data frame que solo sea para los de #LATAM y asi trabajamos con un tsibble más pequeña Vacunas_latam_tsibble <- Vacunastotales_tsibble %>% dplyr::select( Daily, location, total_vaccinations, total_vaccinations_per_hundred, daily_vaccinations_per_million) %>% dplyr::filter(location %in% latam) #Tratando los valores faltantes y los que estan fuera de rango #VLT = contracción para Vacunas_latam_tsibble VLT_miss <- Vacunas_latam_tsibble %>% #filter(location %in% latam1) %>% #anti_join(outliers) %>% tsibble::fill_gaps() #aqui se remplazan por valores faltantes #fill(direction = "down") #A continuacion hacemos un modelo ARIMA que se ajuste #a los datos que cotienen "valores faltantes" VLT_fill <- VLT_miss %>% fabletools::model(ARIMA(total_vaccinations_per_hundred)) %>% fabletools::interpolate(VLT_miss) ``` Row ------------------------------------ ### Escenario general ```{r} #Gráfica que representa el escenario general para los paises #de latam en el tiempo vacunados por cada 100 EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) + geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + labs(x = 'meses', y = 'Vacunas aplicadas por cada 100') plotly::ggplotly(EscenarioLatam) #Notas de el gráifco EscenarioLatam #muestra una tendencia creciente #con temporalidad variable #No hay evidencia de comportmaiento ciclico # EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) + # geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + # labs(title = 'Escenario general de vacunación en LATAM ', # x = 'meses', # y = 'Vacunas aplicadas por cada 100') # # #Gráfica que representa el escenario general para los paises # #de latam en el tiempo vacunados por cada 100 (rellenado) # # EscenarioLatam_fill <- ggplot(data = VLT_fill) + # geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) + # labs(title = 'Escenario general de vacunación en LATAM (sin valores faltantes)', # x = 'meses', # y = 'Vacunas aplicadas por cada 100') # # EscenarioLatam_Comparacion = EscenarioLatam + EscenarioLatam_fill # # EscenarioLatam_Comparacion ``` ### Estacionalidad (Mensual) ```{r} # #Visualización por periocidad ------------------------------------------- #Utilizando la función gg_season para hacer graficas #de la vacunación (2 gráficas por pais correspondiente a los # 2 años de los que se tienen datos) por mes. Vacunas_latam_tsibble %>% filter(location %in% latam1) %>% gg_season(total_vaccinations_per_hundred, labels = "both") + labs(y = "Vacunas aplicadas por cada 100", x = "Meses", title = "Vacunación por meses en los diferentes paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g1 #se repite el codigo para hacer lo mismo y luego juntarlos #con el apoyo de patch work Vacunas_latam_tsibble %>% filter(location %in% latam2) %>% gg_season(total_vaccinations_per_hundred, labels = "both") + labs(y = "Vacunas aplicadas por cada 100", x = "Meses", title = "Vacunación por meses en los diferentes paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g2 #No se estiliza que la asignación vaya hasta el final #pues transgrede con el estilo del código, pero se recomienda #en el libro de forescasting para darle "fluidez" a la lectura #del código #Se encuentra interesante que en marzo la mayoría de los paises #tienen una linea constante #Méxio y chile empezaron la vacunación en las últimas semanas #de diciembre # Visualización: Integración de los gráficos con PATCHWORK ----------------------------- #Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras #para los lugares que deseamos que ocupe la letra layout <- ' AAAABBBB AAAABBBB AAAABBBB ' #cambiamos el lugar de las letras en el layout por nuestrras gráficas wrap_plots(A = g1, B = g2, design = layout) ``` ### Estacionalidad (semanal por mes) ```{r} #Aquí vemos las gráficas anteriores más a detalle, pues podemos #ver en que semanas de cada mes hay crecimiento Vacunas_latam_tsibble %>% filter(location %in% latam1) %>% gg_season(total_vaccinations_per_hundred, period = "month") + labs(y = "Vacunas aplicadas por cada 100", x = "Estacionalidad semanal", title = "Vacunación por semanana cada mes en los paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g3 #repetimos el código para la sección 2 Vacunas_latam_tsibble %>% filter(location %in% latam2) %>% gg_season(total_vaccinations_per_hundred, period = "month") + labs(y = "Vacunas aplicadas por cada 100", x = "Estacionalidad semanal", title = "Vacunación por semanana cada mes en los paises de LATAM") + expand_limits(x = ymd(c("2021-02","2021-04"))) -> g4 # Visualización: Integración de los gráficos con PATCHWORK ----------------------------- #Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras #para los lugares que deseamos que ocupe la letra layout <- ' AAAABBBB AAAABBBB AAAABBBB ' #cambiamos el lugar de las letras en el layout por nuestrras gráficas wrap_plots(A = g3, B = g4, design = layout) ``` Vacunación en LATAM (Pronóstico TSLM) ========================================= Column ------------------------------------ ### TSLM ```{r} # Modelo TSLM ------------------------------------------------------------- #https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/tslm #Descripción #Fit a linear model with time series components #tslm is used to fit linear models to time series including trend and seasonality components. # Definición del modelo #TSLM(total_vaccinations_per_hundred ~ trend()) # Entrenamiento del modelo (Estimación) fit_TSLM <- Vacunas_latam_tsibble %>% fabletools::model(Modelo_tendencia = TSLM(total_vaccinations_per_hundred ~ trend())) #Para datos rellenados fit_TSLM_fill <- VLT_fill %>% fabletools::model(Modelo_tendencia = TSLM(total_vaccinations_per_hundred ~ trend())) # Revisar el desempeño del modelo (evaluación) # Producir pronósticos #Se genera la tabla de pronósticos, el cual va ser #una tabla de tipo fable (objeto) es decir #forecasting table fcst_TSLM <- fit_TSLM %>% forecast(h = 15) #se hace para los siguientes 3 meses #pues los datos que se tienen hasta el momento # son de 4 - 5 meses #tabla de pronósticos, datos rellenados fcst_TSLM_fill <- fit_TSLM_fill %>% forecast(h = 15) # # Visualización de la forecasting table (OLD) # # #para grupo 1 latama # # fcst_TSLM %>% # dplyr::filter(location %in% latam1) %>% # autoplot(Vacunas_latam_tsibble) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1 # # #para grupo 1 latam (rellenado) # # fcst_TSLM_fill %>% # dplyr::filter(location %in% latam1) %>% # autoplot(VLT_fill) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1 # # #para grupo 2 latam # # fcst_TSLM %>% # dplyr::filter(location %in% latam2) %>% # autoplot(Vacunas_latam_tsibble) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g2 # # #para grupo 2 latam (rellenado) # # fcst_TSLM_fill %>% # dplyr::filter(location %in% latam2) %>% # autoplot(VLT_fill) + # ggtitle('Vacunas en LATAM') + # ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g2 #visualización forescatsing table (new) #latam sin rellenar fcst_TSLM %>% autoplot(Vacunas_latam_tsibble) + facet_wrap(~location, ncol = 3, scales = 'free_y') + ggtitle('Pronóstico modelo TSLM ') + xlab('Meses') + ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1 #latam rellenado fcst_TSLM_fill %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + ggtitle('Pronóstico modelo TSLM ') + xlab('Meses') + ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1 #integración de las visualizaciones fcst_TSLM_g3 = fcst_TSLM_g1 + fcst_TSLM_fill_g1 #fcst_TSLM_g3 fcst_TSLM_g1 # fcst_TSLM_fill_g1 ``` Column ------------------------------------ ### TSLM ```{r} fcst_TSLM_fill_g1 ``` Vacunación en LATAM (Pronóstico ETS) ========================================= Column ------------------------------------ ### ETS ```{r} # Modelo ETS (suavización exponencial con tendencia) ---------------------------- #https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/ets #ETS = Exponential smoothing state space model #Description # Returns ETS model applied to "y" #Parámetros estimados #Estimamos alfa (entre 0 y 1, la tasa a la que disminuye "el peso" de los datos en el modelo, tambien conocida como el parametro de suavizacion) #L0 o Lt (nivel, o valor suavizado) #Beta (entre 0 y 1, es el coefficiente que representa la pendiente de la "tendencia" ) # 'A' es para 'aditivo' , 'M' para multiplicativo y 'N' para ninguno # Como nuestros datos tienen una tendencia marcada, seleccionmos que tanto #el error como la tendencia sean "aditivos" fit_ETS_trend <- VLT_fill %>% model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('A') + season('N'))) #Generamos el pronóstico para 5 pasos después fcst_ETS_trend <- fit_ETS_trend %>% forecast(h = 15) %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + labs(title = 'Pronóstico (modelo ETS)', x = 'meses', y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trend_g1 #El método de Holt es el que nos permite hacer suavizacion #exponencial para datos con tendencia #Holt tiene un problema, que la tendencia solo se establece #como creciente o decreciente. Por lo que se desarrollo #una funcion que hace este metodo pero amortiguado # phi es el factor de "amortiguamiento", donde phi # con un valor igual a 1, es identico al metodo de Holt sin # amortiguamiento #Ad -> aditive damped fit_ETS_trendDamped <- VLT_fill %>% model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('Ad') + season('N'))) fcst_ETS_trendDamped <- fit_ETS_trendDamped %>% forecast(h = 15) %>% autoplot(VLT_fill) + facet_wrap(~location, ncol = 3, scales = 'free_y') + labs(title = 'Pronóstico (ETS amortiguado)', x = 'meses', y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trendDamped_g1 fcst_ETS_comparacion = fcst_ETS_trend_g1 + fcst_ETS_trendDamped_g1 #fcst_ETS_comparacion fcst_ETS_trend_g1 ``` Column ------------------------------------ ### ETS amortiguado ```{r} fcst_ETS_trendDamped_g1 ```